Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue62/Alfresco/AANoMem.pas

Pascal/Delphi Source File | 2000-09-02 | 11.5 KB | 429 lines

{*********************************************************}
{* AANoMem                                               *}
{* Copyright (c) Julian M Bucknall 2000                  *}
{* All rights reserved.                                  *}
{*********************************************************}
{* Algorithms Alfresco: Routines that use no heap        *}
{*********************************************************}

{Note: this unit is released as freeware. In other words, you are free
       to use this unit in your own applications, however I retain all
       copyright to the code. JMB}

unit AANoMem;

interface

uses
  Windows;

{===memory comparison===}
function aaCompareMem(aSrc   : pointer;
                      aLen   : integer;
                      aValue : byte) : boolean;

{===PChar routines===}
function aaStrPas(aSrc : PChar) : shortstring;
function aaByteAsHexZ(aDest : PChar; B : byte) : PChar;
function aaPointerAsHexZ(aDest : PChar; P : pointer) : PChar;

{===registry routines===}
function aaReadRegistryInt(aKey     : PChar;
                           aValue   : PChar;
                           aDefault : integer) : integer;

function aaReadRegistryString(aDest    : PChar;
                              aDestSize: DWORD;
                              aKey     : PChar;
                              aValue   : PChar;
                              aDefault : PChar) : PChar;

{===logging routines===}
procedure aaLogOpen(var aLog     : System.Text;
                  const aLogName : shortstring);
procedure aaLogClose(var aLog : System.Text);
procedure aaLogWriteBuffer(var aLog : System.Text;
                           aBuffer : pointer; aBufLen : integer);

implementation

var
  LogLock  : TRTLCriticalSection;
  FirstLog : boolean;

{===memory comparison================================================}
function aaCompareMem(aSrc   : pointer;
                      aLen   : integer;
                      aValue : byte) : boolean;
var
  Mem : PChar;
  i   : integer;
begin
  if (aSrc = nil) then
    Result := false
  else if (aLen <= 0) then
    Result := false
  else begin
    Result := true;
    Mem := aSrc;
    for i := 1 to aLen do begin
      if (Mem^ <> char(aValue)) then begin
        Result := false;
        Exit;
      end;
      inc(Mem);
    end;
  end;
end;
{====================================================================}


{===PChar routines===================================================}
function aaByteAsHexZ(aDest : PChar; B : byte) : PChar;
const
  HexChars : array [0..15] of char = '0123456789abcdef';
begin
  if (aDest <> nil) then begin
    aDest[0] := HexChars[B shr 4];
    aDest[1] := HexChars[B and $F];
    aDest[2] := #0;
  end;
  Result := aDest;
end;
{--------}
function aaPointerAsHexZ(aDest : PChar; P : pointer) : PChar;
var
  L : longint;
begin
  if (aDest <> nil) then begin
    L := longint(P);
    aDest^ := '$';
    inc(aDest);
    aaByteAsHexZ(aDest, L shr 24);
    inc(aDest, 2);
    aaByteAsHexZ(aDest, (L shr 16) and $FF);
    inc(aDest, 2);
    aaByteAsHexZ(aDest, (L shr 8) and $FF);
    inc(aDest, 2);
    aaByteAsHexZ(aDest, L and $FF);
  end;
  Result := aDest;
end;
{--------}
function aaStrPas(aSrc : PChar) : shortstring;
var
  Len : integer;
begin
  Len := lstrlen(aSrc);
  if (Len > 255) then
    Len := 255;
  Result[0] := char(Len);
  Move(aSrc^, Result[1], Len);
end;
{====================================================================}


{===registry routines================================================}
function aaReadRegistryInt(aKey     : PChar;
                           aValue   : PChar;
                           aDefault : integer) : integer;
var
  Handle     : HKEY;
  ValueType  : DWORD;
  DestSize   : DWORD;
begin
  Result := aDefault;
  if (RegOpenKey(HKEY_CURRENT_USER, aKey, Handle) = 0) then begin
    DestSize := sizeof(integer);
    if (RegQueryValueEx(Handle, aValue, nil,
                        @ValueType, PByte(@Result), @DestSize) = 0) then
      if (ValueType <> REG_DWORD) then
        Result := aDefault;
  end;
end;
{--------}
function aaReadRegistryString(aDest    : PChar;
                              aDestSize: DWORD;
                              aKey     : PChar;
                              aValue   : PChar;
                              aDefault : PChar) : PChar;
var
  Handle     : HKEY;
  ValueType  : DWORD;
  UseDefault : boolean;
begin
  Result := aDest;
  UseDefault := true;
  if (RegOpenKey(HKEY_CURRENT_USER, aKey, Handle) = 0) then
    if (RegQueryValueEx(Handle, aValue, nil,
                        @ValueType, PByte(aDest), @aDestSize) = 0) then
      if (ValueType = REG_SZ) then
        UseDefault := false;
  if UseDefault then
    lstrcpy(aDest, aDefault);
end;
{====================================================================}


{===logging routines=================================================}
{these const and type blocks are copied from SysUtils, a unit we
 cannot use since its initialization section allocated memory}
const
  fmClosed = $D7B0;
  fmInput  = $D7B1;
  fmOutput = $D7B2;
  fmInOut  = $D7B3;
type
  PTextBuf = ^TTextBuf;
  TTextBuf = array[0..127] of Char;
  TTextRec = packed record
    Handle: Integer;
    Mode: Integer;
    BufSize: Cardinal;
    BufPos: Cardinal;
    BufEnd: Cardinal;
    BufPtr: PChar;
    OpenFunc: Pointer;
    InOutFunc: Pointer;
    FlushFunc: Pointer;
    CloseFunc: Pointer;
    aaHandle : THandle;
    UserData: array[1..28] of Byte;
    Name: array[0..259] of Char;
    Buffer: TTextBuf;
  end;
{--------}
function TextLogOpen(var F : TTextRec): integer;
var
  OpenMode   : Cardinal;
  ShareMode  : Cardinal;
  CreateMode : Cardinal;
begin
  {set the modes that make sense for each type of open}
  case F.Mode of
    fmInput  :
      begin
        OpenMode := GENERIC_READ;
        ShareMode := FILE_SHARE_READ;
        CreateMode := OPEN_EXISTING;
      end;
    fmOutput :
      begin
        OpenMode := GENERIC_WRITE;
        ShareMode := FILE_SHARE_READ;
        CreateMode := CREATE_ALWAYS;
      end;
    fmInOut  :
      begin
        OpenMode := GENERIC_READ or GENERIC_WRITE;
        ShareMode := FILE_SHARE_READ;
        CreateMode := OPEN_EXISTING;
      end;
  else
    {this isn't really necessary; it fools the warning checker though}
    OpenMode := 0;
    ShareMode := 0;
    CreateMode := 0;
  end;
  {open the file}
  F.aaHandle := CreateFile(F.Name, OpenMode, ShareMode, nil,
                           CreateMode, FILE_ATTRIBUTE_NORMAL, 0);
  {if the file could not be opened, return the error}
  if (F.aaHandle = INVALID_HANDLE_VALUE) then begin
    Result := GetLastError;
  end
  {otherwise prepare for I/O}
  else begin
    F.BufPos := 0;
    F.BufEnd := 0;
    Result := 0;
    if (F.Mode = fmInOut) then begin
      {for Append, ensure we're at the end of the file}
      SetFilePointer(F.aaHandle, 0, nil, FILE_END);
      F.Mode := fmOutput;
    end;
  end;
end;
{--------}
function TextLogInOut(var F : TTextRec): integer;
var
  BytesRead : Cardinal;
  BytesWrit : Cardinal;
begin
  Result := 0;
  {read}
  if (F.Mode = fmInput) then begin
    F.BufPos := 0;
    if ReadFile(F.aaHandle, F.Buffer, F.BufSize, BytesRead, nil) then
      F.BufEnd := BytesRead
    else
      Result := GetLastError;
  end
  {write}
  else begin
    if WriteFile(F.aaHandle, F.Buffer, F.BufPos, BytesWrit, nil) then
      if (BytesWrit <> F.BufPos) then
        Result := 101 {disk full?}
      else
        F.BufPos := 0
    else
      Result := GetLastError;
  end;
end;
{--------}
function TextLogFlush(var F : TTextRec): integer;
begin
  {we don't do any flushing: the log file is going to be closed
   pretty soon anyway}
  Result := 0;
end;
{--------}
function TextLogClose(var F : TTextRec): integer;
begin
  {close the file}
  if (F.Mode <> fmClosed) then begin
    if CloseHandle(F.aaHandle) then
      Result := 0
    else
      Result := GetLastError
  end
  else
    Result := 103; {= file not open}
end;
{--------}
procedure AssignLog(var aLog     : System.Text;
                  const aLogName : shortstring);
begin
  with TTextRec(aLog) do begin
    Mode := fmClosed;
    BufSize := sizeof(Buffer);
    BufPtr := @Buffer;
    OpenFunc := @TextLogOpen;
    InOutFunc := @TextLogInOut;
    FlushFunc := @TextLogFlush;
    CloseFunc := @TextLogClose;
    aaHandle := INVALID_HANDLE_VALUE;
    Move(aLogName[1], Name[0], length(aLogName));
    Name[length(aLogName)] := #0;
  end;
end;
{--------}
procedure aaLogOpen(var aLog     : System.Text;
                  const aLogName : shortstring);
begin
  EnterCriticalSection(LogLock);
  try
    AssignLog(aLog, aLogName);
    if FirstLog then
      System.Rewrite(aLog)
    else
      System.Append(aLog);
    try
      if FirstLog then begin
        writeln(aLog, 'Algorithms Alfresco Log');
        writeln(aLog, '-----------------------');
        writeln(aLog);
        FirstLog := false;
      end;
    except
      System.Close(aLog);
      raise;
    end;
  except
    LeaveCriticalSection(LogLock);
    raise;
  end;
end;
{--------}
procedure aaLogClose(var aLog : System.Text);
begin
  try
    System.Close(aLog);
  finally
    LeaveCriticalSection(LogLock);
  end;
end;
{--------}
procedure aaLogWriteBuffer(var aLog : System.Text;
                           aBuffer : pointer; aBufLen : integer);
var
  Line      : array [0..70] of char;
  HexByte   : array [0..2] of char;
  ByteCount : integer;
  B         : PChar;
  i         : integer;
  HexPos    : integer;
  CharPos   : integer;
begin
  {this routine prints a buffer in the usual hex format:
0----+----1----+----2----+----3----+----4----+----5----+----6----+----7
xx xx xx xx  xx xx xx xx  xx xx xx xx  xx xx xx xx [cccccccccccccccc]
  sixteen bytes to a line}

  {initialize the line buffer}
  FillChar(Line, sizeof(Line), ' ');
  Line[70] := #0;
  Line[51] := '[';
  Line[68] := ']';

  {output the buffer, 16 bytes at a time}
  B := PChar(aBuffer);
  ByteCount := 0;
  HexPos := 0;
  CharPos := 52;
  for i := 0 to pred(aBufLen) do begin
    {we're adding another byte, so check that we haven't filled up the
     current line}
    if (ByteCount = 16) then begin
      writeln(aLog, Line);
      FillChar(Line[0], 50, ' ');
      FillChar(Line[52], 16, ' ');
      ByteCount := 0;
      HexPos := 0;
      CharPos := 52;
    end;
    {convert the current byte to hex}
    aaByteAsHexZ(HexByte, byte(B[i]));
    {set the hex value and the character}
    Line[HexPos] := HexByte[0];
    Line[HexPos+1] := HexByte[1];
    if (' ' <= B[i]) and (B[i] < #$7F) then
      Line[CharPos] := B[i]
    else
      Line[CharPos] := '.';
    {advance}
    inc(ByteCount);
    inc(HexPos, 3);
    if ((ByteCount and $3) = 0) then
      inc(HexPos);
    inc(CharPos);
  end;
  {write out the last (partial) line}
  writeln(aLog, Line);
end;
{====================================================================}


{===Initialization/finalization======================================}
procedure InitializeUnit;
begin
  {create the log lock for multithreaded apps}
  InitializeCriticalSection(LogLock);
  FirstLog := true;
end;
{--------}
procedure FinalizeUnit;
begin
  {destroy the log lock}
  DeleteCriticalSection(LogLock);
end;
{--------}
initialization
  InitializeUnit;
{--------}
finalization
  FinalizeUnit;
{====================================================================}

end.